Shareware Grab Bag/Shareware Grab Bag.iso/050/turbio.arc/DOS2IO-1.INC

Text File | 1985-08-17 | 14KB | 503 lines

(*
                   Dos2io-1.inc


    Dedicated to the public domain.
                -- Cole Brecheen
                   17 August 1985
*)

{$V-}   {Relaxes type checking on string parameters; must
                      also be turned off in the main file.}
{$U-,C-,R-} {Enables keyboard buffering.}

CONST
  null = '';
    {A vestige of IBM Pascal, which does not allow '' as a
    string literal.  Helps distinguish '' from a literal
    space.}

  BufSize = 255;
  inp = 0;
  outp = 1;
    {The PC-DOS v2.0 manual at D-15 explains the significance
    of these numbers.}

TYPE
  ErrorMessage  = (
           NoError,
           BadFunction,
           FileNotFound,
           PathNotFound,
           NoHandlesLeft,
           AccessDenied,
           BadHandle,
           MCBsDestroyed,
           TooLittleMemory,
           BadMemBlockAddr,
           BadEnvironment,
           BadFormat,
           BadAccessCode,
           BadData,
           MissingMessage,
    {The PC-DOS v2.0 user's manual doesn't list a message
    14.}
           InvalidDrive,
           CurrentDirErase,
           DifferentDevice,
           NoMoreFiles,
    {These are the 18 MS-DOS standard error messages.  See
    PC-DOS v2.0 user's manual at D-14.  The function
    MessageType, below, depends on your keeping them in their
    present order.  The messages below are added for
    convenience.}
           EndOfFile,
           PartialRead
          );

  BufType = PACKED ARRAY [1..BufSize] OF CHAR;


  DataRegister =
    RECORD
      CASE BOOLEAN OF
    TRUE :      ( l : BYTE ;
          h : BYTE );
    FALSE : ( x : INTEGER );
      END;

  regpack =
    RECORD
      a, b, c, d: DataRegister;
      bp, si, di, ds, es, flags: INTEGER;
    END;
    {This is the record type used with the msdos procedure.}

  dos2str80 = STRING[80];
  dos2str255 = STRING[255];
  dos2charset = set of CHAR;
  dos2numset = set of 0..255;

VAR
  choice :  CHAR;
  TypeAheadLegal : BOOLEAN;


FUNCTION MessageType( FunctionResult: byte ): ErrorMessage;
VAR
  converter : RECORD CASE BOOLEAN of
        true : ( num : byte );
        false : ( msg : ErrorMessage );
          END;
BEGIN {MessageType}
  converter.num := FunctionResult;
  MessageType := converter.msg;
    {The case variant allows coverter to be referred to both
    as a byte and as an ErrorMessage.}
END; {MessageType}


PROCEDURE WriteStr( FileHandle : INTEGER;
            TheStr : dos2str255 ); forward;

PROCEDURE WriteEol( FileHandle : INTEGER ); forward;


PROCEDURE abort( message : dos2str80 );
BEGIN {abort}
  WriteEol( outp );
  WriteStr( outp, message );
  WriteEol( outp );
  WriteStr( outp, 'Press <return>.' );
  readln;
    {Can't use GetKey here because GetKey may abort for lack
    of initialization.  A GetKey inside GetKey would cause
    endless loop.}
  halt;
END;  {abort}



PROCEDURE PrintMessage( functionresult: errormessage );
BEGIN {PrintMessage}
  CASE functionresult OF
    NoError : BEGIN END;
    BadFunction : abort( 'Invalid function number.' );
    FileNotFound : abort( 'File not found.' );
    PathNotFound : abort( 'Path not found.' );
    NoHandlesLeft : abort( 'No handles left.' );
    AccessDenied : abort( 'Access denied.' );
    BadHandle : abort( 'Invalid handle.' );
    MCBsDestroyed : abort( 'Memory control blocks destroyed.' );
    TooLittleMemory : abort( 'Insufficient memory.' );
    BadMemBlockAddr : abort( 'Invalid memory block address.' );
    BadEnvironment : abort( 'Invalid environment.' );
    BadFormat : abort( 'Invalid format.' );
    BadAccessCode : abort( 'Invalid access code.' );
    BadData : abort( 'Invalid data.' );
    MissingMessage : abort( 'Missing message 14.' );
    InvalidDrive : abort( 'Invalid drive was specified.' );
    CurrentDirErase : abort('Can''t remove current directory.');
    DifferentDevice : abort( 'Different device.' );
    NoMoreFiles : abort( 'No more files.' );

    PartialRead : write( 'Partial read.' );
    EndOfFile : write( 'End of file.' );
    {We don't have an else because, if the runtime system
    decides that some different value is possible, we want to
    know.}
  END; {case}
END; {PrintMessage}


FUNCTION FlaggedError( TheFlags : INTEGER ): BOOLEAN;
    {Detects the PC/MS-DOS error signal in the carry flag.}
BEGIN
  FlaggedError := odd( abs( TheFlags ) );
END; {FlaggedError}



PROCEDURE AddStr( VAR first : dos2str255; second : dos2str255 );
    {Concatenates the second string onto the end of the
    first.  Requires less typing and executes more
    efficiently than doing the same thing with Turbo's concat
    function.}
BEGIN
  first[0] := succ( first[0] );
  insert( second, first, length(first) );
  first[0] := pred( first[0] );
END; {AddStr}



PROCEDURE MakeAsciiZ( VAR TheStr : dos2str255 );
VAR
  lngth,
  index : INTEGER;
BEGIN
  IF lngth > 0 THEN
    FOR index := 0 TO (lngth - 1) DO
      BEGIN
        TheStr[ index ] := TheStr[ index + 1 ];
      END;
  TheStr[lngth] := #0;
END; {MakeAsciiZ}



PROCEDURE WriteStr{ FileHandle : INTEGER; TheStr : dos2str255 };
VAR
  rgstr : regpack;
BEGIN {WriteStr}
  IF FileHandle = inp
    THEN abort( 'Cannot write to standard input.' );
  with rgstr DO BEGIN
    b.x := FileHandle;
    c.x := length( TheStr );
    MakeAsciiZ( TheStr );
    ds := seg( TheStr );
    d.x := ofs( TheStr );
    a.h := $40;  {Write to a file or device command}
    msdos( rgstr );
    IF FlaggedError( flags )
      THEN PrintMessage( MessageType( a.x ) );
    IF a.x < c.x  {if fewer than c.x bytes were actually written}
      THEN abort( 'No room to write.' );
  END; {with rgstr}
END;  {WriteStr}



FUNCTION IntStr( TheNumber : INTEGER;
         StrLngth: INTEGER ): dos2str80;
VAR
  BufStr : dos2str80;
BEGIN {IntStr}
  str( TheNumber:StrLngth, BufStr );
    {See the Turbo Pascal manual at p. 108 for an
    explanation of how StrLngth functions in this statement.}
  IntStr := BufStr;
END; {IntStr}


FUNCTION RealStr( TheNumber : REAL;
          StrLngth,
          DigitsAfterDecimal : INTEGER ): dos2str80;
VAR
  BufStr : dos2str80;
BEGIN {RealStr}
  str( TheNumber:StrLngth:DigitsAfterDecimal, BufStr );
  RealStr := BufStr;
END; {RealStr}


PROCEDURE WriteEol{ FileHandle : INTEGER };
BEGIN {WriteEol}
  WriteStr( FileHandle, concat( #13, #10 ) );
END;  {WriteEol}



TYPE
  BufferPtr = ^FileBuff;
    {This is the record type that ReadStr uses to perform
    dynamic file buffering.}

  FileBuff = RECORD
           buf : buftype;
    {There's a mysterious problem lurking here somewhere that
    takes an eggbeater to the heap if buf is made the last
    item in this record.  It doesn't seem to show up if buf
    is the first item.}

           prev,
           next : BufferPtr;
           ndx,
           handle, size : INTEGER;
           eof : BOOLEAN;
         END;
VAR
  BufLstBase : BufferPtr;
  Dos2ioInitKey : REAL;


PROCEDURE InitDos2io;
BEGIN
  TypeAheadLegal := true;
  BufLstBase := nil;
  Dos2ioInitKey := 5721.0;
END; {InitDos2io}

PROCEDURE CheckInitialization;
BEGIN
  IF Dos2ioInitKey <> 5721.0 THEN
    abort( 'Please initialize with InitDos2io.' );
END; {CheckInitialization}


PROCEDURE ReadStr( FileHandle : INTEGER;
           VAR TheStr : dos2str255 );
LABEL EndProcedure;
VAR
  BufPtr : BufferPtr;
  Strlong: dos2str255;

  PROCEDURE load( VAR BufPtr : BufferPtr );
  VAR
    rgstr : regpack;
    eofpos : INTEGER;
  BEGIN
    with rgstr DO BEGIN
      b.x := FileHandle;
      c.x := BufSize;
    {CX gets the number of bytes to be transferred.}
      ds := seg( BufPtr^.buf );
      d.x := ofs( BufPtr^.buf );
      a.h := $3F;
    {Read from a file or device command.}
      msdos( rgstr );
      IF FlaggedError( flags )
    THEN BEGIN writeln('readstr error');  {diag}
      PrintMessage( MessageType( a.x ) );
      END;
      BufPtr^.size := a.x;
    {AX contains the number of bytes actually transferred.
    If the value is zero, the program has tried to read from
    the end of file. }
      IF FileHandle <> 0 THEN BufPtr^.ndx := BufPtr^.ndx - BufSize
        ELSE BufPtr^.ndx := 1;
      eofpos := pos(#26,BufPtr^.buf);
      IF eofpos <> 0 THEN  BEGIN
        BufPtr^.buf[eofpos] := #13;
        BufPtr^.size := eofpos - 1;
      END;
      IF BufPtr^.size = BufSize THEN BufPtr^.size := BufSize + 3;
      BufPtr^.eof := BufPtr^.size = 0;
    END; {with rgstr}
  END; {load}

  PROCEDURE MakeBuffFor( FileHandle : INTEGER );
  LABEL
    EndProcedure;
  VAR
    OldPtr, TmpPtr : BufferPtr;
  BEGIN
    IF BufLstBase = nil THEN
      BEGIN
    {If there are no file buffers in the BufLst at all (i.e,
    if BufLstBase is nil), the next few lines will create the
    first buffer and put its address in BufLstBase.}
    new( TmpPtr );
    BufLstBase := TmpPtr;
    TmpPtr^.ndx := BufSize + 1;
    TmpPtr^.next := nil;
    TmpPtr^.prev := nil;
    TmpPtr^.handle := FileHandle;
    GOTO EndProcedure;
      END;

    TmpPtr := BufLstBase;

    WHILE (TmpPtr^.handle <> FileHandle)
      and
      (TmpPtr^.next <> nil)
      DO TmpPtr := TmpPtr^.next;
    {This checks to see whether a buffer for this file is
    already in the BufLst.  If not, the if-then construct
    immediately below will create one and add it to the
    BufLst.}

    IF TmpPtr^.handle <> FileHandle THEN
      BEGIN
    OldPtr := TmpPtr;
    new( TmpPtr );
    OldPtr^.next := TmpPtr;
    TmpPtr^.prev := OldPtr;
    TmpPtr^.ndx := BufSize + 1;
    TmpPtr^.next := nil;
    TmpPtr^.handle := FileHandle;
      END;

    EndProcedure:
    BufPtr := TmpPtr;
  END;  {MakeBuffFor}

  PROCEDURE MoveLine( VAR BufPtr : BufferPtr;
              VAR TheLine : dos2str255 );
    {Takes one line from the buffer and puts it in TheLine.}
  VAR  endstr: INTEGER;
  LABEL EndProcedure;
  BEGIN
    TheLine := copy(BufPtr^.buf,BufPtr^.ndx,BufSize - BufPtr^.ndx + 1);
    endstr :=pos(#13,TheLine);
    IF endstr = 0 THEN BEGIN   {no CR in rest of current buffer}
      IF BufPtr^.size > BufSize THEN BEGIN  {eof not in current buffer}
        BufPtr^.ndx := BufSize + 1;
        load( BufPtr );
        endstr := pos(#13, BufPtr^.buf);
        IF endstr = 0 THEN     {no CR in new buufer either}
          IF BufPtr^.size < BufSize THEN BEGIN  {if eof in this buffer}
            endstr := BufPtr^.size + 1;
            BufPtr^.eof := TRUE;
          END  {IF BufPtr^.size < BufSize}
          ELSE  abort('line too long:' + copy(TheLine,1,60) + '...');
        TheLine := TheLine + copy(BufPtr^.buf,1,endstr -1);
        BufPtr^.ndx := endstr + 2; {jumps over following LF}
      END
      ELSE BEGIN  {eof is in current buffer}
        TheLine[0] := Chr(BufPtr^.size);
        BufPtr^.eof := TRUE;
      END;
    END   {IF endstr = 0 }
    ELSE BEGIN    {CR is in current buffer}
      TheLine[0] := Chr(endstr - 1);
      BufPtr^.ndx := BufPtr^.ndx + endstr + 1; {+1 jumps over following LF}
    END;
    EndProcedure:
    END; {MoveLine}

BEGIN {ReadStr}
  CheckInitialization;
  IF FileHandle = outp
    THEN abort( 'Cannot read from standard output.' );
  TheStr := null;
  MakeBuffFor( FileHandle );
  IF (BufPtr^.ndx > BufSize) OR (FileHandle = 0) THEN load( BufPtr );
  MoveLine( BufPtr, Strlong );
  IF (BufPtr^.ndx > BufPtr^.size) AND (FileHandle <> 0) THEN BufPtr^.eof := TRUE
  ELSE IF (BufPtr^.ndx > BufSize) AND (FileHandle <> 0) THEN load( BufPtr );
  TheStr := Strlong;
END;  {ReadStr}


FUNCTION EndReached( FileHandle : INTEGER ): BOOLEAN;
LABEL ErrorLabel;
VAR
  TmpPtr : BufferPtr;
BEGIN
  CheckInitialization;
  TmpPtr := BufLstBase;
  IF TmpPtr = nil
    THEN GOTO ErrorLabel;
  WHILE (TmpPtr^.handle <> FileHandle)
    and
    (TmpPtr^.next <> nil)
    DO TmpPtr := TmpPtr^.next;
  IF TmpPtr^.handle <> FileHandle
    THEN
      ErrorLabel:
      abort('ReadStr(handle) must precede EndReached(handle).');
  EndReached := TmpPtr^.eof;
END; {EndReached}



PROCEDURE GetKey( VAR ch:CHAR; ReturnOnMatch: dos2charset );
VAR
  rgstr : regpack;
BEGIN {GetKey}
  CheckInitialization;
  IF TypeAheadLegal
    {Works only if U- and C- compiler directives are set in
    all files.}
    THEN rgstr.A.H := 8
    {Console input without echo.}
    ELSE rgstr.A.H := $C;
    {Clear standard input buffer and invoke the input
    function stored in AL.      See D-20 of PC-DOS 2.0 manual.}
  REPEAT
    rgstr.A.L := 8;
    msdos( rgstr );
    ch := CHR(rgstr.A.L);
  UNTIL ch IN ReturnOnMatch;
END; {GetKey}



PROCEDURE GetExtendedKey( VAR ch    : CHAR;
                  legalchars : dos2charset;
                  legalxkeys : dos2numset;
                  VAR xkeygotten : BOOLEAN );
VAR
  byte1,
  byte2 : BYTE;
  rgstr : regpack;

BEGIN {GetExtendedKey}
  CheckInitialization;
  IF TypeAheadLegal
    {Works only if U- and C- compiler directives are set in
    all files.}
    THEN rgstr.A.H := 8
    ELSE rgstr.A.H := $C;

  REPEAT
    rgstr.A.L := 8;
    MsDos( rgstr );
    byte1 := rgstr.A.L;
    IF CHR(byte1) = CHR(0)
      THEN
    BEGIN
      rgstr.A.H := 8;
      MsDos( rgstr );
      byte2 := rgstr.A.L;
    END;
  UNTIL ( CHR(byte1) IN legalchars)
    OR
    ( (byte1 = 0) AND (ORD(byte2) IN legalxkeys));
  IF CHR(byte1) = CHR(0)
    THEN
      BEGIN
        ch := CHR(byte2);
        xkeygotten := TRUE;
      END
    ELSE
      BEGIN
        ch := CHR(byte1);
        xkeygotten := FALSE;
      END;
END; {GetExtendedKey}